home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue70 / Clinic / COMSolution2 / ComClientU.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-04-06  |  2.2 KB  |  101 lines
  1. unit ComClientU;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.     Button1: TButton;
  12.     Button2: TButton;
  13.     procedure Button1Click(Sender: TObject);
  14.     procedure Button2Click(Sender: TObject);
  15.   private
  16.     { Private declarations }
  17.   public
  18.     { Public declarations }
  19.   end;
  20.  
  21. var
  22.   Form1: TForm1;
  23.  
  24. implementation
  25.  
  26. {$R *.DFM}
  27.  
  28. uses
  29.   BaseLib_TLB, CommonUnit, ActiveX, ComObj;
  30.  
  31. var
  32.   DllList: TStringList;
  33.  
  34. function GetIFoo(const DllName: String): IFoo;
  35. var
  36.   Idx: Integer;
  37.   Dll: THandle;
  38.   DllGetClassObject: function (const CLSID, IID: TGUID; var Obj): HResult; stdcall;
  39.   FooFactory: IClassFactory;
  40. begin
  41.   //Is DLL already in list?
  42.   Idx := DllList.IndexOf(DllName);
  43.   //If not, load it and add it
  44.   if Idx = -1 then
  45.   begin
  46.     Dll := LoadLibrary(PChar(DllName));
  47.     if Dll = 0 then
  48.       RaiseLastWin32Error;
  49.     DllList.AddObject(DllName, Pointer(Dll));
  50.   end
  51.   //else locate it
  52.   else
  53.     Dll := THandle(DllList.Objects[Idx]);
  54.   //Find the key function
  55.   DllGetClassObject := GetProcAddress(DLL, 'DllGetClassObject');
  56.   if not Assigned(@DllGetClassObject) then
  57.     RaiseLastWin32Error;
  58.   //Call it to get the class factory
  59.   OleCheck(DllGetClassObject(SharedClassID, IClassFactory, FooFactory));
  60.   //Ask the class factory the COM object
  61.   if Assigned(FooFactory) then
  62.     OleCheck(FooFactory.CreateInstance(nil, IFoo, Result));
  63. end;
  64.  
  65. procedure TidyUpDllList;
  66. var
  67.   I: Integer;
  68.   DllCanUnloadNow: function: HResult; stdcall;
  69. begin
  70.   for I := 0 to DllList.Count - 1 do
  71.   begin
  72.     DllCanUnloadNow := GetProcAddress(THandle(DllList.Objects[0]), 'DllCanUnloadNow');
  73.     if Assigned(@DllCanUnloadNow) and (DllCanUnloadNow = S_OK)then
  74.       Freelibrary(THandle(DllList.Objects[0]));
  75.   end;
  76.   DllList.Free;
  77.   DllList := nil
  78. end;
  79.  
  80. procedure TForm1.Button1Click(Sender: TObject);
  81. var
  82.   Foo: IFoo;
  83. begin
  84.   Foo := GetIFoo('ComServer1.Dll');
  85.   Foo.Bar;
  86. end;
  87.  
  88. procedure TForm1.Button2Click(Sender: TObject);
  89. var
  90.   Foo: IFoo;
  91. begin
  92.   Foo := GetIFoo('ComServer2.Dll');
  93.   Foo.Bar;
  94. end;
  95.  
  96. initialization
  97.   DllList := TStringList.Create;
  98. finalization
  99.   TidyUpDllList
  100. end.
  101.